{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lambola.FI
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Foreign Interface .
-- 
--------------------------------------------------------------------------------

module Lambola.FI
   

  where


import Control.Applicative
import Control.Monad
import Data.Char
import Data.List.Split

-- "Obviously" this needs a string rewriting combinator 
-- library...
--
underscoreToCase :: String -> String
underscoreToCase ss = first $ ss
  where
    first (x:xs) | isLetter x   = toUpper x : second xs
    first xs                    = second xs

    second ('_':xs)             = goUpper xs
    second (x:xs) | isLetter x  = toLower x : second xs
    second (x:xs)               = x : second xs
    second []                   = []

    goUpper (x:xs) | isLetter x = toUpper x : second xs
    goUpper xs                  = second xs

utc :: String -> String
utc = concat . map namecase . splitOn "_"
  where
    namecase (x:xs) = toUpper x : map toLower xs
    namecase xs     = map toLower xs


type ErrMsg = String

data Result a = Success !RState a
              | Failure !ErrMsg

instance Functor Result where
  fmap f (Success st a) = Success st (f a)
  fmap _ (Failure msg)  = Failure msg



data RState = RState
   { st_result :: ShowS
   , st_input  :: String
   }

newtype Rewrite a = Rewrite { getRewrite :: RState -> Result a }

-- Should Rewrite actually be:
--
-- > newtype GenRewrite a = GenRewrite { getRewrite :: RState -> Result a }
--
-- > type Rewrite = GenRewrite ()
--
-- ... and we de-emphasize the monadic implementation in the API 
-- (QuickCheck style)?
--

instance Functor Rewrite where
  fmap f ma = Rewrite $ \s -> fmap f $ getRewrite ma s


instance Applicative Rewrite where
  pure a    = Rewrite $ \s -> Success s a
  mf <*> ma = Rewrite $ \s -> case getRewrite mf s of
                Success s1 f -> case getRewrite ma s1 of
                  Success s2 a -> Success s2 (f a)
                  Failure msg  -> Failure msg
                Failure msg  -> Failure msg

instance Alternative Rewrite where
  empty = failure
  (<|>) = alt

instance Monad Rewrite where
  return    = pure
  m >>= k   = Rewrite $ \s -> case getRewrite m s of
                Success s1 a -> getRewrite (k a) s1
                Failure msg  -> Failure msg

instance MonadPlus Rewrite where
  mzero = failure
  mplus = alt

unshows :: ShowS -> String
unshows = ($ "")

snocString :: RState -> String -> RState
snocString st ss = upd st
  where
    upd = (\s a -> s { st_result = a . showString ss })  <*> st_result

snocChar :: RState -> Char -> RState 
snocChar st ch = upd st 
  where
    upd = (\s a -> s { st_result = a . showChar ch })  <*> st_result


-- alternatively to snoc (which we won\'t export), tell

tellChar :: Char -> Rewrite ()
tellChar ch = Rewrite $ \s -> Success (s `snocChar` ch) ()

tellString :: String -> Rewrite ()
tellString ss = Rewrite $ \s -> Success (s `snocString` ss) ()


runRewrite :: Rewrite a -> String -> Either ErrMsg (String,a)
runRewrite ma inp = 
    let s0 = RState { st_result = id, st_input = inp} in 
    case getRewrite ma s0 of
      Success st a -> Right (unshows $ st_result st, a)
      Failure msg  -> Left msg


-- | If the rewrite fails return the input string...
rewrite :: Rewrite a -> String -> Either ErrMsg String
rewrite ma = fmap fst . runRewrite ma


alt :: Rewrite a -> Rewrite a -> Rewrite a
alt ma mb = Rewrite $ \s -> case getRewrite ma s of
    Success s1 a -> Success s1 a 
    Failure _    -> getRewrite mb s

failure :: Rewrite a
failure = Rewrite $ \_ -> Failure "failure"

infix 0 <?> 

(<?>) :: Rewrite a -> String -> Rewrite a
ma <?> msg = Rewrite $ \s -> case getRewrite ma s of
    Failure _ -> Failure msg
    okay      -> okay

-- Do we need failure to implement eof?

eof :: Rewrite ()
eof = Rewrite $ \s -> case st_input s of
    []  -> Success s ()
    _   -> Failure "eof - not eof" 

assert :: (Char -> Bool) -> Rewrite ()
assert test = Rewrite $ \s -> case st_input s of
    (x:_) | test x -> Success s ()
    _              -> Failure "assert - test failed" 


anyChar :: Rewrite ()
anyChar = Rewrite $ \s -> case st_input s of
    (x:xs) -> let s1 = s { st_input = xs } in Success (snocChar s1 x) ()
    _      -> Failure "anyChar - empty input" 

anyChar1 :: Rewrite Char
anyChar1 = Rewrite $ \s -> case st_input s of
    (x:xs) -> Success (s { st_input=xs }) x
    _      -> Failure "anyChar1 - empty input" 

-- Is it better to have standard parser combintors and then 
-- combine them with explicit calls to tell to make rewrite rules?
--
any1 :: Rewrite ()
any1 = anyChar1 >>= tellChar

literal1 :: (Char -> Bool) -> Rewrite Char
literal1 test = Rewrite $ \s -> case st_input s of
    (x:xs) | test x    -> Success (s { st_input=xs }) x
           | otherwise -> Failure "literal1 - unmatched"
    _      -> Failure "literal1 - empty input" 


drop1 :: Rewrite ()
drop1 = Rewrite $ \s -> case st_input s of
    (_:xs) -> let s1 = s { st_input = xs } in Success s1 ()
    _      -> Failure "dropChar - empty input" 

dropWhen :: (Char -> Bool) -> Rewrite ()
dropWhen test = assert test >> drop1 <?> "dropWhen - assert failed"

trail :: Rewrite ()
trail = Rewrite $ \s -> case st_input s of
    []  -> Success s ()
    xs  -> let s1 = s { st_input = [] } in Success (snocString s1 xs) ()

trailBy :: (Char -> Char) -> Rewrite ()
trailBy f = Rewrite $ \s -> case st_input s of
    []  -> Success s ()
    xs  -> let s1 = s { st_input = [] } 
           in Success (snocString s1 $ map f xs) ()


-- and combinator for multiple traversals?
